home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / rules.scm < prev    next >
Encoding:
Text File  |  1992-01-30  |  4.5 KB  |  150 lines
  1. ; Rewrite-rule compiler (a.k.a. "extend-syntax")
  2.  
  3. ; To do:
  4. ;   Fix bug with nested ... patterns
  5. ;   Apply rename and compare functions everywhere they should be
  6.  
  7. ; Example:
  8. ;
  9. ; (define-syntax or
  10. ;   (syntax-rules ()
  11. ;     ((or) #f)
  12. ;     ((or e) e)
  13. ;     ((or e1 e ...) (let ((temp e1))
  14. ;               (if temp temp (or e ...))))))
  15.  
  16. (define (rewrite-syntax-rules exp r c)
  17.   (process-rules (cddr exp) (cadr exp) r c))
  18.  
  19. (define (process-rules rules subkeywords r c)
  20.   (let ((tail (r 'tail)))
  21.     `(,(r 'lambda) (%input% %rename% %compare%) ;These should be renamed...
  22.        (,(r 'let) ((,tail (,(r 'cdr) %input%)))
  23.      (,(r 'cond) ,@(map (lambda (rule)
  24.             (process-rule rule tail subkeywords r c))
  25.               rules)
  26.            (,(r 'else)
  27.         (syntax-error "use of macro doesn't match definition"
  28.                   %input%)))))))
  29.  
  30. (define (process-rule rule tail subkeywords r c)
  31.   (if (not (= (length rule) 2))
  32.       (syntax-error "ill-formed rule" rule))
  33.   (let ((pattern (car rule))
  34.     (template (cadr rule)))
  35.     (let ((env (process-pattern (cdr pattern) tail null-rank subkeywords)))
  36.       `(,(process-match tail (cdr pattern) subkeywords)
  37.     (,(r 'let*) ,(map (lambda (z)
  38.                 `(,(car z) ,(cadr z)))
  39.               env)
  40.       ,(process-template template env null-rank))))))
  41.  
  42. (define null-rank '())
  43.  
  44. ; Generate code to test whether input expression matches pattern
  45.  
  46. (define (process-match input pattern subkeywords)
  47.   (cond ((name? pattern)
  48.      (if (member pattern subkeywords)
  49.          `(%compare% ,input ',pattern)
  50.          `#t))
  51.     ((zero-or-more? pattern)
  52.      (process-list-match input (car pattern) subkeywords))
  53.     ((at-least-one? pattern)
  54.      `(and (not (null? ,input))
  55.            ,(process-list-match input (car pattern) subkeywords)))
  56.     ((pair? pattern)
  57.      `(let ((%temp% ,input))
  58.         (and (pair? %temp%)
  59.          ,(process-match `(car %temp%) (car pattern) subkeywords)
  60.          ,(process-match `(cdr %temp%) (cdr pattern) subkeywords))))
  61.     (else
  62.      `(equal? ,input ',pattern))))
  63.  
  64. (define (process-list-match input pattern subkeywords)
  65.   `(let loop ((l ,input))
  66.      (or (null? l)
  67.      (and (pair? l)
  68.           ,(process-match '(car l) pattern subkeywords)
  69.           (loop (cdr l))))))
  70.  
  71. ; Generate code to take apart the input expression
  72.  
  73. (define (process-pattern pattern path rank subkeywords)
  74.   (cond ((name? pattern)
  75.      (if (name-member pattern subkeywords)
  76.          '()
  77.          (list (list pattern path rank))))
  78.     ((or (zero-or-more? pattern)
  79.          (at-least-one? pattern))
  80.      (let ((temp '%temp%))  ;Bug -- should gensym here!!
  81.        (cons `(,temp ,path)
  82.          (map (lambda (z)
  83.             `(,(car z)
  84.               (map (lambda (%input%)
  85.                  ,(cadr z))
  86.                ,temp)
  87.               ,(caddr z)))
  88.               (process-pattern (car pattern)
  89.                        '%input%
  90.                        (cons (cadr pattern) rank)
  91.                        subkeywords)))))
  92.     ((pair? pattern)
  93.      (append (process-pattern (car pattern) `(car ,path) rank subkeywords)
  94.          (process-pattern (cdr pattern) `(cdr ,path) rank subkeywords)))
  95.     (else '())))
  96.  
  97. ; Generate code to compose the output expression according to template
  98.  
  99. (define (process-template template env rank)
  100.   (cond ((name? template)
  101.      (let ((probe (name-assoc template env)))
  102.        (if probe
  103.            (if (equal? (caddr probe) rank)
  104.            template
  105.            (syntax-error "syntax-rules: template rank error" template))
  106.            `(%rename% ',template))))
  107.     ((or (zero-or-more? template)
  108.          (at-least-one? template))
  109.      (let ((vars (free-template-vars (car template) env '())))
  110.        (if (null? vars)
  111.            (syntax-error "ill-formed template" template)
  112.            `(map (lambda ,vars
  113.                ,(process-template (car template)
  114.                       env
  115.                       (cons (cadr template) rank)))
  116.              ,@vars))))
  117.     ((pair? template)
  118.      `(cons ,(process-template (car template) env rank)
  119.         ,(process-template (cdr template) env rank)))
  120.     (else `',template)))
  121.  
  122. (define (free-template-vars template env free)
  123.   (cond ((name? template)
  124.      (if (and (name-assoc template env)
  125.           (not (name-member template free)))
  126.          (cons template free)
  127.          free))
  128.     ((or (zero-or-more? template)
  129.          (at-least-one? template))
  130.      (free-template-vars (cadr template) env free))
  131.     ((pair? template)
  132.      (free-template-vars (car template) env
  133.                  (free-template-vars (cdr template) env free)))
  134.     (else free)))
  135.  
  136. (define (check-cadr syms)
  137.   (lambda (pattern)
  138.     (and (pair? pattern)
  139.      (pair? (cdr pattern))
  140.      (memq (cadr pattern) syms)
  141.      (or (null? (cddr pattern))
  142.          (syntax-error "segment matching not implemented" pattern)))))
  143.  
  144. ;(define zero-or-more? (check-cadr `(* ,(string->symbol "..."))))
  145. ;(define at-least-one? (check-cadr '(+)))
  146. (define (at-least-one? x) #f)
  147.  
  148. (define zero-or-more?
  149.   (check-cadr (list (string->symbol "...") '---)))
  150.